home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / utils / sysdep.el.z / sysdep.el
Encoding:
Text File  |  1998-05-21  |  33.7 KB  |  917 lines
  1. ;;; sysdep.el --- consolidate Emacs-version dependencies in one file.
  2.  
  3. ;; Copyright (C) 1995 Ben Wing.
  4.  
  5. ;; Author: Ben Wing <wing@666.com>
  6. ;; Keywords: lisp, tools
  7.  
  8. ;; This file is part of XEmacs.
  9.  
  10. ;; XEmacs is free software; you can redistribute it and/or modify it
  11. ;; under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; XEmacs is distributed in the hope that it will be useful, but
  16. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18. ;; General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with XEmacs; see the file COPYING.  If not, write to the 
  22. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23. ;; Boston, MA 02111-1307, USA.
  24.  
  25. ;;; Synched up with: Not in FSF.
  26.  
  27. ;; The purpose of this file is to eliminate the cruftiness that
  28. ;; would otherwise be required of packages that want to run on multiple
  29. ;; versions of Emacs.  The idea is that we make it look like we're running
  30. ;; the latest version of XEmacs (currently 19.14) by emulating all the
  31. ;; missing functions.
  32.  
  33. ;; #### This file does not currently do any advising but should.
  34. ;; Unfortunately, advice.el is a hugely big package.  Is any such
  35. ;; thing as `advice-lite' possible?
  36.  
  37. ;; #### - This package is great, but its role needs to be thought out a bit
  38. ;; more.  Sysdep will not permit programs written for the old XEmacs API to
  39. ;; run on new versions of XEmacs.  Sysdep is a backward-compatibility
  40. ;; package for the latest and greatest XEmacs API.  It permits programmers
  41. ;; to use the latest XEmacs functionality and still have their programs run
  42. ;; on older versions of XEmacs...perhaps even on FSF Emacs.  It should NEVER
  43. ;; ever need to be loaded in the newest XEmacs.  It doesn't even make sense
  44. ;; to put it in the lisp/utils part of the XEmacs distribution because its
  45. ;; real purpose is to be distributed with packages like w3 which take
  46. ;; advantage of the latest and greatest features of XEmacs but still need to
  47. ;; be run on older versions.  --Stig
  48.  
  49. ;; Any packages that wish to use this file should load it using
  50. ;; `load-library'.  It will not load itself if a version of sysdep.el
  51. ;; that is at least as recent has already been loaded, but will
  52. ;; load over an older version of sysdep.el.  It will attempt to
  53. ;; not redefine functions that have already been custom-redefined,
  54. ;; but will redefine a function if the supplied definition came from
  55. ;; an older version of sysdep.el.
  56.  
  57. ;; Packages such as w3 that wish to include this file with the package
  58. ;; should rename it to something unique, such as `w3-sysdep.el', and
  59. ;; load it with `load-library'.  That will ensure that no conflicts
  60. ;; arise if more than one package in the load path provides a version
  61. ;; of sysdep.el.  If multiple packages load sysdep.el, the most recent
  62. ;; version will end up loaded; as long as I'm careful not to
  63. ;; introduce bugs in previously working definitions, this should work
  64. ;; fine.
  65.  
  66. ;; You may well discover deficiencies in this file as you use it.
  67. ;; The preferable way of dealing with this is to send me a patch
  68. ;; to sysdep.el; that way, the collective body of knowledge gets
  69. ;; increased.
  70.  
  71. ;; DO NOT load this file with `require'.
  72. ;; DO NOT put a `provide' statement in this file.
  73.  
  74. ;; IMPORTANT: leave the version string in the format X.XXX (e.g. 1.001)
  75. ;; so that string comparisons to other versions work properly.
  76.  
  77. (defconst sysdep-potential-version "0.002")
  78.  
  79. (if (and (boundp 'sysdep-version)
  80.      (not (string-lessp sysdep-version sysdep-potential-version)))
  81.     ;; if a more recent version of sysdep was already loaded,
  82.     ;; or if the same package is loaded again, don't load.
  83.     nil
  84.  
  85. (defconst sysdep-version sysdep-potential-version)
  86.  
  87. ;; this macro means: define the function, but only if either it
  88. ;; wasn't bound before, or the supplied binding comes from an older
  89. ;; version of sysdep.el.  That way, user-supplied bindings don't
  90. ;; get overridden.
  91.  
  92. ;; note: sysdep-defalias is often more useful than this function,
  93. ;; esp. since you can do load-time conditionalizing and can
  94. ;; optionally leave the function undefined. (e.g. frame functions
  95. ;; in v18.)
  96.  
  97. (defmacro sysdep-defun (function &rest everything-else)
  98.   (` (cond ((or (not (fboundp (quote (, function))))
  99.         (get (quote (, function)) 'sysdep-defined-this))
  100.         (put (quote (, function)) 'sysdep-defined-this t)
  101.         (defun (, function) (,@ everything-else))))))
  102.  
  103. (defmacro sysdep-defvar (function &rest everything-else)
  104.   (` (cond ((or (not (boundp (quote (, function))))
  105.         (get (quote (, function)) 'sysdep-defined-this))
  106.         (put (quote (, function)) 'sysdep-defined-this t)
  107.         (defvar (, function) (,@ everything-else))))))
  108.  
  109. (defmacro sysdep-defconst (function &rest everything-else)
  110.   (` (cond ((or (not (boundp (quote (, function))))
  111.         (get (quote (, function)) 'sysdep-defined-this))
  112.         (put (quote (, function)) 'sysdep-defined-this t)
  113.         (defconst (, function) (,@ everything-else))))))
  114.  
  115. ;; similar for fset and defalias.  No need to quote as the argument
  116. ;; is already quoted.
  117.  
  118. (defmacro sysdep-fset (function def)
  119.   (` (cond ((and (or (not (fboundp (, function)))
  120.              (get (, function) 'sysdep-defined-this))
  121.          (, def))
  122.         (put (, function) 'sysdep-defined-this t)
  123.         (fset (, function) (, def))))))
  124.  
  125. (defmacro sysdep-defalias (function def)
  126.   (` (cond ((and (or (not (fboundp (, function)))
  127.              (get (, function) 'sysdep-defined-this))
  128.          (, def)
  129.          (or (listp (, def))
  130.              (and (symbolp (, def))
  131.               (fboundp (, def)))))
  132.         (put (, function) 'sysdep-defined-this t)
  133.         (defalias (, function) (, def))))))
  134.  
  135. ;; bootstrapping: defalias and define-function don't exist
  136. ;; in older versions of lemacs
  137.  
  138. (sysdep-fset 'defalias 'fset)
  139. (sysdep-defalias 'define-function 'defalias)
  140.  
  141. ;; useful ways of determining what version is running
  142. ;; emacs-major-version and emacs-minor-version are
  143. ;; already defined in recent versions of FSF Emacs and XEmacs
  144.  
  145. (sysdep-defconst emacs-major-version
  146.          ;; will string-match ever fail?  If so, assume 19.0.
  147.          ;; (should we assume 18.something?)
  148.          (if (string-match "^[0-9]+" emacs-version)
  149.              (string-to-int
  150.               (substring emacs-version
  151.                  (match-beginning 0) (match-end 0)))
  152.            19))
  153.  
  154. (sysdep-defconst emacs-minor-version
  155.          (if (string-match "^[0-9]+\\.\\([0-9]+\\)" emacs-version)
  156.              (string-to-int
  157.               (substring emacs-version
  158.                  (match-beginning 1) (match-end 1)))
  159.            0))
  160.  
  161. (sysdep-defconst sysdep-running-xemacs
  162.          (or (string-match "Lucid" emacs-version)
  163.              (string-match "XEmacs" emacs-version)))
  164.  
  165. (sysdep-defconst window-system nil)
  166. (sysdep-defconst window-system-version 0)
  167.  
  168. (sysdep-defvar list-buffers-directory nil)
  169. (sysdep-defvar x-library-search-path '("/usr/X11R6/lib/X11/"
  170.                        "/usr/X11R5/lib/X11/"
  171.                        "/usr/lib/X11R6/X11/"
  172.                        "/usr/lib/X11R5/X11/"
  173.                        "/usr/local/X11R6/lib/X11/"
  174.                        "/usr/local/X11R5/lib/X11/"
  175.                        "/usr/local/lib/X11R6/X11/"
  176.                        "/usr/local/lib/X11R5/X11/"
  177.                        "/usr/X11/lib/X11/"
  178.                        "/usr/lib/X11/"
  179.                        "/usr/local/lib/X11/"
  180.                        "/usr/X386/lib/X11/"
  181.                        "/usr/x386/lib/X11/"
  182.                        "/usr/XFree86/lib/X11/"
  183.                        "/usr/unsupported/lib/X11/"
  184.                        "/usr/athena/lib/X11/"
  185.                        "/usr/local/x11r5/lib/X11/"
  186.                        "/usr/lpp/Xamples/lib/X11/"
  187.                        "/usr/openwin/lib/X11/"
  188.                        "/usr/openwin/share/lib/X11/")
  189.   "Search path used for X11 libraries.")
  190.  
  191. ;; frame-related stuff.
  192.  
  193. (sysdep-defalias 'buffer-dedicated-frame 'buffer-dedicated-screen)
  194. (sysdep-defalias 'deiconify-frame
  195.   (cond ((fboundp 'deiconify-screen) 'deiconify-screen)
  196.     ;; make-frame-visible will be defined as necessary
  197.     (t 'make-frame-visible)))
  198. (sysdep-defalias 'delete-frame 'delete-screen)
  199. (sysdep-defalias 'event-frame 'event-screen)
  200. (sysdep-defalias 'event-glyph-extent 'event-glyph)
  201. (sysdep-defalias 'find-file-other-frame 'find-file-other-screen)
  202. (sysdep-defalias 'find-file-read-only-other-frame
  203.   'find-file-read-only-other-screen)
  204. (sysdep-defalias 'frame-height 'screen-height)
  205. (sysdep-defalias 'frame-iconified-p 'screen-iconified-p)
  206. (sysdep-defalias 'frame-left-margin-width 'screen-left-margin-width)
  207. (sysdep-defalias 'frame-list 'screen-list)
  208. (sysdep-defalias 'frame-live-p
  209.   (cond ((fboundp 'screen-live-p) 'screen-live-p)
  210.     ((fboundp 'live-screen-p) 'live-screen-p)
  211.     ;; #### not sure if this is correct (this is for Epoch)
  212.     ;; but gnuserv.el uses it this way
  213.     ((fboundp 'screenp) 'screenp)))
  214. (sysdep-defalias 'frame-name 'screen-name)
  215. (sysdep-defalias 'frame-parameters 'screen-parameters)
  216. (sysdep-defalias 'frame-pixel-height 'screen-pixel-height)
  217. (sysdep-defalias 'frame-pixel-width 'screen-pixel-width)
  218. (sysdep-defalias 'frame-right-margin-width 'screen-right-margin-width)
  219. (sysdep-defalias 'frame-root-window 'screen-root-window)
  220. (sysdep-defalias 'frame-selected-window 'screen-selected-window)
  221. (sysdep-defalias 'frame-totally-visible-p 'screen-totally-visible-p)
  222. (sysdep-defalias 'frame-visible-p 'screen-visible-p)
  223. (sysdep-defalias 'frame-width 'screen-width)
  224. (sysdep-defalias 'framep 'screenp)
  225. (sysdep-defalias 'get-frame-for-buffer 'get-screen-for-buffer)
  226. (sysdep-defalias 'get-frame-for-buffer-noselect 'get-screen-for-buffer-noselect)
  227. (sysdep-defalias 'get-other-frame 'get-other-screen)
  228. (sysdep-defalias 'iconify-frame 'iconify-screen)
  229. (sysdep-defalias 'lower-frame 'lower-screen)
  230. (sysdep-defalias 'mail-other-frame 'mail-other-screen)
  231.  
  232. (sysdep-defalias 'make-frame
  233.   (cond ((fboundp 'make-screen)
  234.      (function (lambda (&optional parameters device)
  235.              (make-screen parameters))))
  236.     ((fboundp 'x-create-screen)
  237.      (function (lambda (&optional parameters device)
  238.              (x-create-screen parameters))))))
  239.  
  240. (sysdep-defalias 'make-frame-invisible 'make-screen-invisible)
  241. (sysdep-defalias 'make-frame-visible
  242.   (cond ((fboundp 'make-screen-visible) 'make-screen-visible)
  243.     ((fboundp 'mapraised-screen) 'mapraised-screen)
  244.     ((fboundp 'x-remap-window)
  245.      (lambda (&optional x)
  246.        (x-remap-window)
  247.        (accept-process-output)))))
  248. (sysdep-defalias 'modify-frame-parameters 'modify-screen-parameters)
  249. (sysdep-defalias 'new-frame 'new-screen)
  250. (sysdep-defalias 'next-frame 'next-screen)
  251. (sysdep-defalias 'next-multiframe-window 'next-multiscreen-window)
  252. (sysdep-defalias 'other-frame 'other-screen)
  253. (sysdep-defalias 'previous-frame 'previous-screen)
  254. (sysdep-defalias 'previous-multiframe-window 'previous-multiscreen-window)
  255. (sysdep-defalias 'raise-frame
  256.   (cond ((fboundp 'raise-screen) 'raise-screen)
  257.     ((fboundp 'mapraise-screen) 'mapraise-screen)))
  258. (sysdep-defalias 'redraw-frame 'redraw-screen)
  259. (sysdep-defalias 'select-frame 'select-screen)
  260. (sysdep-defalias 'selected-frame 'selected-screen)
  261. (sysdep-defalias 'set-buffer-dedicated-frame 'set-buffer-dedicated-screen)
  262. (sysdep-defalias 'set-frame-height 'set-screen-height)
  263. (sysdep-defalias 'set-frame-left-margin-width 'set-screen-left-margin-width)
  264. (sysdep-defalias 'set-frame-position 'set-screen-position)
  265. (sysdep-defalias 'set-frame-right-margin-width 'set-screen-right-margin-width)
  266. (sysdep-defalias 'set-frame-size 'set-screen-size)
  267. (sysdep-defalias 'set-frame-width 'set-screen-width)
  268. (sysdep-defalias 'show-temp-buffer-in-current-frame 'show-temp-buffer-in-current-screen)
  269. (sysdep-defalias 'switch-to-buffer-other-frame 'switch-to-buffer-other-screen)
  270. (sysdep-defalias 'visible-frame-list 'visible-screen-list)
  271. (sysdep-defalias 'window-frame 'window-screen)
  272. (sysdep-defalias 'x-create-frame 'x-create-screen)
  273. (sysdep-defalias 'x-set-frame-icon-pixmap 'x-set-screen-icon-pixmap)
  274. (sysdep-defalias 'x-set-frame-pointer 'x-set-screen-pointer)
  275. (sysdep-defalias 'x-display-color-p 'x-color-display-p)
  276. (sysdep-defalias 'x-display-grayscale-p 'x-grayscale-display-p)
  277. (sysdep-defalias 'menu-event-p 'misc-user-event-p)
  278.  
  279. (sysdep-defun add-submenu (menu-path submenu &optional before)
  280.   "Add a menu to the menubar or one of its submenus.
  281. If the named menu exists already, it is changed.
  282. MENU-PATH identifies the menu under which the new menu should be inserted.
  283.  It is a list of strings; for example, (\"File\") names the top-level \"File\"
  284.  menu.  (\"File\" \"Foo\") names a hypothetical submenu of \"File\".
  285.  If MENU-PATH is nil, then the menu will be added to the menubar itself.
  286. SUBMENU is the new menu to add.
  287.  See the documentation of `current-menubar' for the syntax.
  288. BEFORE, if provided, is the name of a menu before which this menu should
  289.  be added, if this menu is not on its parent already.  If the menu is already
  290.  present, it will not be moved."
  291.   (add-menu menu-path (car submenu) (cdr submenu) before))
  292.  
  293. (sysdep-defun add-menu-button (menu-path menu-leaf &optional before)
  294.   "Add a menu item to some menu, creating the menu first if necessary.
  295. If the named item exists already, it is changed.
  296. MENU-PATH identifies the menu under which the new menu item should be inserted.
  297.  It is a list of strings; for example, (\"File\") names the top-level \"File\"
  298.  menu.  (\"File\" \"Foo\") names a hypothetical submenu of \"File\".
  299. MENU-LEAF is a menubar leaf node.  See the documentation of `current-menubar'.
  300. BEFORE, if provided, is the name of a menu item before which this item should
  301.  be added, if this item is not on the menu already.  If the item is already
  302.  present, it will not be moved."
  303.  (add-menu-item menu-path (aref menu-leaf 0) (aref menu-leaf 1)
  304.         (aref menu-leaf 2) before))
  305.  
  306. (sysdep-defun make-glyph (&optional spec-list)
  307.   (if (and spec-list (cdr-safe (assq 'x spec-list)))
  308.       (make-pixmap (cdr-safe (assq 'x spec-list)))))
  309.  
  310. (sysdep-defalias 'face-list 'list-faces)
  311.  
  312. (sysdep-defun set-face-property (face property value &optional locale
  313.                       tag-set how-to-add)
  314.   "Change a property of FACE."
  315.   (and (symbolp face)
  316.        (put face property value)))
  317.  
  318. (sysdep-defun face-property (face property &optional locale tag-set exact-p)
  319.   "Return FACE's value of the given PROPERTY."
  320.   (and (symbolp face) (get face property)))
  321.  
  322. ;; Device functions
  323. ;; By wmperry@spry.com
  324. ;; This is a complete implementation of all the device-* functions found in
  325. ;; XEmacs 19.14.  A 'device' for Emacs 19 is just a frame, from which we can
  326. ;; determine the connection to an X display, etc.
  327.  
  328. (sysdep-defalias 'selected-device 'ignore)
  329. (sysdep-defalias 'device-or-frame-p 'framep)
  330. (sysdep-defalias 'device-console 'ignore)
  331. (sysdep-defalias 'device-sound-enabled-p 'ignore)
  332. (sysdep-defalias 'device-live-p 'frame-live-p)
  333. (sysdep-defalias 'devicep 'framep)
  334. (sysdep-defalias 'frame-device 'identity)
  335. (sysdep-defalias 'redisplay-device 'redraw-frame)
  336. (sysdep-defalias 'redraw-device 'redraw-frame)
  337. (sysdep-defalias 'select-device 'select-frame)
  338. (sysdep-defalias 'set-device-class 'ignore)
  339.  
  340. (sysdep-defun make-device (type connection &optional props)
  341.   "Create a new device of type TYPE, attached to connection CONNECTION.
  342.  
  343. The valid values for CONNECTION are device-specific; however,
  344. CONNECTION is generally a string. (Specifically, for X devices,
  345. CONNECTION should be a display specification such as \"foo:0\", and
  346. for TTY devices, CONNECTION should be the filename of a TTY device
  347. file, such as \"/dev/ttyp4\", or nil to refer to XEmacs' standard
  348. input/output.)
  349.  
  350. PROPS, if specified, should be a plist of properties controlling
  351. device creation.
  352.  
  353. If CONNECTION specifies an already-existing device connection, that
  354. device is simply returned; no new device is created, and PROPS
  355. have no effect."
  356.   (cond
  357.    ((and (eq type 'x) connection)
  358.     (make-frame-on-display display props))
  359.    ((eq type 'x)
  360.     (make-frame props))
  361.    ((eq type 'tty)
  362.     nil)
  363.    (t
  364.     (error "Unsupported device-type: %s" type))))
  365.  
  366. (sysdep-defun make-frame-on-device (type connection &optional props)
  367.   "Create a frame of type TYPE on CONNECTION.
  368. TYPE should be a symbol naming the device type, i.e. one of
  369.  
  370. x    An X display.  CONNECTION should be a standard display string
  371.     such as \"unix:0\", or nil for the display specified on the
  372.     command line or in the DISPLAY environment variable.  Only if
  373.     support for X was compiled into    XEmacs.
  374. tty    A standard TTY connection or terminal.  CONNECTION should be
  375.     a TTY device name such as \"/dev/ttyp2\" (as determined by
  376.     the Unix command `tty') or nil for XEmacs' standard input
  377.     and output (usually the TTY in which XEmacs started).  Only
  378.     if support for TTY's was compiled into XEmacs.
  379. ns    A connection to a machine running the NeXTstep windowing
  380.     system.  Not currently implemented.
  381. win32    A connection to a machine running Microsoft Windows NT or
  382.     Windows 95.  Not currently implemented.
  383. pc    A direct-write MS-DOS frame.  Not currently implemented.
  384.  
  385. PROPS should be a plist of properties, as in the call to `make-frame'.
  386.  
  387. If a connection to CONNECTION already exists, it is reused; otherwise,
  388. a new connection is opened."
  389.   (make-device type connection props))
  390.  
  391. (sysdep-defun make-tty-device (&optional tty terminal-type)
  392.   "Create a new device on TTY.
  393.   TTY should be the name of a tty device file (e.g. \"/dev/ttyp3\" under
  394. SunOS et al.), as returned by the `tty' command.  A value of nil means
  395. use the stdin and stdout as passed to XEmacs from the shell.
  396.   If TERMINAL-TYPE is non-nil, it should be a string specifying the
  397. type of the terminal attached to the specified tty.  If it is nil,
  398. the terminal type will be inferred from the TERM environment variable."
  399.   (make-device 'tty tty (list 'terminal-type terminal-type)))
  400.  
  401. (sysdep-defun make-x-device (&optional display)
  402.   (make-device 'x display))
  403.  
  404. (sysdep-defun set-device-selected-frame (device frame)
  405.   "Set the selected frame of device object DEVICE to FRAME.
  406. If DEVICE is nil, the selected device is used.
  407. If DEVICE is the selected device, this makes FRAME the selected frame."
  408.   (select-frame frame))
  409.  
  410. (sysdep-defun set-device-baud-rate (device rate)
  411.   "Set the output baud rate of DEVICE to RATE.
  412. On most systems, changing this value will affect the amount of padding
  413. and other strategic decisions made during redisplay."
  414.   (setq baud-rate rate))
  415.  
  416. (sysdep-defun dfw-device (obj)
  417.   "Given a device, frame, or window, return the associated device.
  418. Return nil otherwise."
  419.   (cond
  420.    ((windowp obj)
  421.     (window-frame obj))
  422.    ((framep obj)
  423.     obj)
  424.    (t
  425.     nil)))
  426.  
  427. (sysdep-defun event-device (event)
  428.   "Return the device that EVENT occurred on.
  429. This will be nil for some types of events (e.g. keyboard and eval events)."
  430.   (dfw-device (posn-window (event-start event))))
  431.  
  432. (sysdep-defun find-device (connection &optional type)
  433.   "Look for an existing device attached to connection CONNECTION.
  434. Return the device if found; otherwise, return nil.
  435.  
  436. If TYPE is specified, only return devices of that type; otherwise,
  437. return devices of any type. (It is possible, although unlikely,
  438. that two devices of different types could have the same connection
  439. name; in such a case, the first device found is returned.)"
  440.   (let ((devices (device-list))
  441.     (retval nil))
  442.     (while (and devices (not nil))
  443.       (if (equal connection (device-connection (car devices)))
  444.       (setq retval (car devices)))
  445.       (setq devices (cdr devices)))
  446.     retval))
  447.  
  448. (sysdep-defalias 'get-device 'find-device)
  449.  
  450. (sysdep-defun device-baud-rate (&optional device)
  451.   "Return the output baud rate of DEVICE."
  452.   baud-rate)
  453.  
  454. (sysdep-defun device-on-window-system-p (&optional device)
  455.   "Return non-nil if DEVICE is on a window system.
  456. This generally means that there is support for the mouse, the menubar,
  457. the toolbar, glyphs, etc."
  458.   (and (cdr-safe (assq 'display (frame-parameters device))) t))
  459.  
  460. (sysdep-defun device-name (&optional device)
  461.   "Return the name of the specified device."
  462.   ;; doesn't handle the 19.29 multiple X display stuff yet
  463.   ;; doesn't handle NeXTStep either
  464.   (cond
  465.    ((null window-system) "stdio")
  466.    ((getenv "DISPLAY")
  467.     (let ((str (getenv "DISPLAY"))
  468.       (x (1- (length (getenv "DISPLAY"))))
  469.       (y 0))
  470.       (while (/= y x)
  471.     (if (or (= (aref str y) ?:)
  472.         (= (aref str y) ?.))
  473.         (aset str y ?-))
  474.     (setq y (1+ y)))
  475.       str))
  476.    (t "stdio")))
  477.  
  478.  
  479. (sysdep-defun device-connection (&optional device)
  480.   "Return the connection of the specified device.
  481. DEVICE defaults to the selected device if omitted"
  482.   (or (cdr-safe (assq 'display (frame-parameters device))) "stdio"))
  483.  
  484. (sysdep-defun device-frame-list (&optional device)
  485.   "Return a list of all frames on DEVICE.
  486. If DEVICE is nil, the selected device will be used."
  487.   (let ((desired (device-connection device)))
  488.     (filtered-frame-list (function (lambda (x) (equal (device-connection x)
  489.                               desired))))))
  490. (sysdep-defun device-list ()
  491.   "Return a list of all devices"
  492.   (let ((seen nil)
  493.     (cur nil)
  494.     (conn nil)
  495.     (retval nil)
  496.     (not-heard (frame-list)))
  497.     (while not-heard
  498.       (setq cur (car not-heard)
  499.         conn (device-connection cur)
  500.         not-heard (cdr not-heard))
  501.       (if (member conn seen)
  502.       nil                ; Already got it
  503.     (setq seen (cons conn seen)    ; Whoo hoo, a new one!
  504.           retval (cons cur retval))))
  505.     retval))
  506.  
  507. (sysdep-defvar delete-device-hook nil
  508.   "Function or functions to call when a device is deleted.
  509. One argument, the to-be-deleted device.")
  510.  
  511. (sysdep-defun delete-device (device &optional force)
  512.   "Delete DEVICE, permanently eliminating it from use.
  513. Normally, you cannot delete the last non-minibuffer-only frame (you must
  514. use `save-buffers-kill-emacs' or `kill-emacs').  However, if optional
  515. second argument FORCE is non-nil, you can delete the last frame. (This
  516. will automatically call `save-buffers-kill-emacs'.)"
  517.   (let ((frames (device-frame-list device)))
  518.     (run-hook-with-args 'delete-device-hook device)
  519.     (while frames
  520.       (delete-frame (car frames) force)
  521.       (setq frames (cdr frames)))))
  522.  
  523. (sysdep-defalias 'device-color-cells
  524.   (cond
  525.    ((null window-system) 'ignore)
  526.    ((fboundp 'display-color-cells) 'display-color-cells)
  527.    ((fboundp 'x-display-color-cells) 'x-display-color-cells)
  528.    ((fboundp 'ns-display-color-cells) 'ns-display-color-celles)
  529.    (t 'ignore)))
  530.  
  531. (sysdep-defun try-font-name (fontname &rest args)
  532.   (car-safe (x-list-fonts fontname)))
  533.  
  534. (sysdep-defalias 'device-pixel-width
  535.   (cond
  536.    ((and (eq window-system 'x) (fboundp 'x-display-pixel-width))
  537.     'x-display-pixel-width)
  538.    ((and (eq window-system 'ns) (fboundp 'ns-display-pixel-width))
  539.     'ns-display-pixel-width)
  540.    (t 'ignore)))
  541.  
  542. (sysdep-defalias 'device-pixel-height
  543.   (cond
  544.    ((and (eq window-system 'x) (fboundp 'x-display-pixel-height))
  545.     'x-display-pixel-height)
  546.    ((and (eq window-system 'ns) (fboundp 'ns-display-pixel-height))
  547.     'ns-display-pixel-height)
  548.    (t 'ignore)))
  549.  
  550. (sysdep-defalias 'device-mm-width
  551.   (cond
  552.    ((and (eq window-system 'x) (fboundp 'x-display-mm-width))
  553.     'x-display-mm-width)
  554.    ((and (eq window-system 'ns) (fboundp 'ns-display-mm-width))
  555.     'ns-display-mm-width)
  556.    (t 'ignore)))
  557.  
  558. (sysdep-defalias 'device-mm-height
  559.   (cond
  560.    ((and (eq window-system 'x) (fboundp 'x-display-mm-height))
  561.     'x-display-mm-height)
  562.    ((and (eq window-system 'ns) (fboundp 'ns-display-mm-height))
  563.     'ns-display-mm-height)
  564.    (t 'ignore)))
  565.  
  566. (sysdep-defalias 'device-bitplanes
  567.   (cond
  568.    ((and (eq window-system 'x) (fboundp 'x-display-planes))
  569.     'x-display-planes)
  570.    ((and (eq window-system 'ns) (fboundp 'ns-display-planes))
  571.     'ns-display-planes)
  572.    (t 'ignore)))
  573.  
  574. (sysdep-defalias 'device-class
  575.   (cond
  576.    ((and (eq window-system 'x) (fboundp 'x-display-visual-class))
  577.     (function
  578.      (lambda (&optional device)
  579.        (let ((val (symbol-name (x-display-visual-class device))))
  580.      (cond
  581.       ((string-match "color" val) 'color)
  582.       ((string-match "gray-scale" val) 'grayscale)
  583.       (t 'mono))))))
  584.    ((fboundp 'number-of-colors)
  585.     (function
  586.      (lambda (&optional device)
  587.        (if (= 2 (number-of-colors))
  588.        'mono
  589.      'color))))
  590.    ((and (eq window-system 'x) (fboundp 'x-color-p))
  591.     (function
  592.      (lambda (&optional device)
  593.        (if (x-color-p)
  594.        'color
  595.      'mono))))
  596.    ((and (eq window-system 'ns) (fboundp 'ns-display-visual-class))
  597.     (function
  598.      (lambda (&optional device)
  599.        (let ((val (symbol-name (ns-display-visual-class))))
  600.      (cond
  601.       ((string-match "color" val) 'color)
  602.       ((string-match "gray-scale" val) 'grayscale)
  603.       (t 'mono))))))
  604.    (t (function (lambda (&optional device) 'mono)))))
  605.  
  606. (sysdep-defun device-class-list ()
  607.   "Returns a list of valid device classes."
  608.   (list 'color 'grayscale 'mono))
  609.  
  610. (sysdep-defun valid-device-class-p (class)
  611.   "Given a CLASS, return t if it is valid.
  612. Valid classes are 'color, 'grayscale, and 'mono."
  613.   (memq class (device-class-list)))
  614.  
  615. (sysdep-defun device-or-frame-type (device-or-frame)
  616.   "Return the type (e.g. `x' or `tty') of DEVICE-OR-FRAME.
  617. DEVICE-OR-FRAME should be a device or a frame object.  See `device-type'
  618. for a description of the possible types."
  619.   (if (cdr-safe (assq 'display (frame-parameters device-or-frame)))
  620.       window-system
  621.     'tty))
  622.  
  623. (sysdep-defun device-type (&optional device)
  624.   "Return the type of the specified device (e.g. `x' or `tty').
  625. Value is `tty' for a tty device (a character-only terminal),
  626. `x' for a device which is a connection to an X server,
  627. 'ns' for a device which is a connection to a NeXTStep dps server,
  628. 'win32' for a Windows-NT window,
  629. 'pm' for an OS/2 Presentation Manager window,
  630. 'intuition' for an Amiga screen"
  631.   (device-or-frame-type device))
  632.  
  633. (sysdep-defun device-type-list ()
  634.   "Return a list of valid console types."
  635.   (if window-system
  636.       (list window-system 'tty)
  637.     (list 'tty)))
  638.  
  639. (sysdep-defun valid-device-type-p (type)
  640.   "Given a TYPE, return t if it is valid."
  641.   (memq type (device-type-list)))
  642.  
  643.  
  644. ;; Extent stuff
  645. (sysdep-fset 'delete-extent 'delete-overlay)
  646. (sysdep-fset 'extent-end-position 'overlay-end)
  647. (sysdep-fset 'extent-start-position 'overlay-start)
  648. (sysdep-fset 'set-extent-endpoints 'move-overlay)
  649.  
  650. (sysdep-defun extent-property (extent property &optional default)
  651.   (or (overlay-get extent property) default))
  652.  
  653. (sysdep-defun extent-at (pos &optional object property before at-flag)
  654.   (let ((tmp (overlays-at (point)))
  655.     ovls)
  656.     (if property
  657.     (while tmp
  658.       (if (extent-property (car tmp) property)
  659.           (setq ovls (cons (car tmp) ovls)))
  660.       (setq tmp (cdr tmp)))
  661.       (setq ovls tmp
  662.         tmp nil))
  663.     (car-safe
  664.      (sort ovls
  665.        (function
  666.         (lambda (a b)
  667.           (< (- (extent-end-position a) (extent-start-position a))
  668.          (- (extent-end-position b) (extent-start-position b)))))))))
  669.  
  670.  
  671. (sysdep-defun overlays-in (beg end)
  672.   "Return a list of the overlays that overlap the region BEG ... END.
  673. Overlap means that at least one character is contained within the overlay
  674. and also contained within the specified region.
  675. Empty overlays are included in the result if they are located at BEG
  676. or between BEG and END."
  677.   (let ((ovls (overlay-lists))
  678.     tmp retval)
  679.     (if (< end beg)
  680.     (setq tmp end
  681.           end beg
  682.           beg tmp))
  683.     (setq ovls (nconc (car ovls) (cdr ovls)))
  684.     (while ovls
  685.       (setq tmp (car ovls)
  686.         ovls (cdr ovls))
  687.       (if (or (and (<= (overlay-start tmp) end)
  688.            (>= (overlay-start tmp) beg))
  689.           (and (<= (overlay-end tmp) end)
  690.            (>= (overlay-end tmp) beg)))
  691.       (setq retval (cons tmp retval))))
  692.     retval))
  693.  
  694. (sysdep-defun map-extents (function &optional object from to
  695.                     maparg flags property value)
  696.   (let ((tmp (overlays-in (or from (point-min))
  697.               (or to (point-max))))
  698.     ovls)
  699.     (if property
  700.     (while tmp
  701.       (if (extent-property (car tmp) property)
  702.           (setq ovls (cons (car tmp) ovls)))
  703.       (setq tmp (cdr tmp)))
  704.       (setq ovls tmp
  705.         tmp nil))
  706.     (catch 'done
  707.       (while ovls
  708.     (setq tmp (funcall function (car ovls) maparg)
  709.           ovls (cdr ovls))
  710.     (if tmp
  711.         (throw 'done tmp))))))
  712.  
  713. ;; misc
  714. (sysdep-defun alist-to-plist (alist)
  715.   "Convert association list ALIST into the equivalent property-list form.
  716. The plist is returned.  This converts from
  717.  
  718. \((a . 1) (b . 2) (c . 3))
  719.  
  720. into
  721.  
  722. \(a 1 b 2 c 3)
  723.  
  724. The original alist is not modified.  See also `destructive-alist-to-plist'."
  725.   (let (plist)
  726.     (while alist
  727.       (let ((el (car alist)))
  728.     (setq plist (cons (cdr el) (cons (car el) plist))))
  729.       (setq alist (cdr alist)))
  730.     (nreverse plist)))
  731.  
  732. (sysdep-defun add-minor-mode (toggle name &optional keymap after toggle-fun)
  733.   "Add a minor mode to `minor-mode-alist' and `minor-mode-map-alist'.
  734. TOGGLE is a symbol which is used as the variable which toggle the minor mode,
  735. NAME is the name that should appear in the modeline (it should be a string
  736. beginning with a space), KEYMAP is a keymap to make active when the minor
  737. mode is active, and AFTER is the toggling symbol used for another minor
  738. mode.  If AFTER is non-nil, then it is used to position the new mode in the
  739. minor-mode alists.  TOGGLE-FUN specifies an interactive function that
  740. is called to toggle the mode on and off; this affects what appens when
  741. button2 is pressed on the mode, and when button3 is pressed somewhere
  742. in the list of modes.  If TOGGLE-FUN is nil and TOGGLE names an
  743. interactive function, TOGGLE is used as the toggle function.
  744.  
  745. Example:  (add-minor-mode 'view-minor-mode \" View\" view-mode-map)"
  746.   (if (not (assq toggle minor-mode-alist))
  747.       (setq minor-mode-alist (cons (list toggle name) minor-mode-alist)))
  748.   (if (and keymap (not (assq toggle minor-mode-map-alist)))
  749.       (setq minor-mode-map-alist (cons (cons toggle keymap)
  750.                        minor-mode-map-alist))))
  751.  
  752. (sysdep-defvar x-font-regexp-foundry-and-family
  753.   (let ((-         "[-?]")
  754.     (foundry        "[^-]+")
  755.     (family         "[^-]+")
  756.     )
  757.     (concat "\\`[-?*]" foundry - "\\(" family "\\)" -)))
  758.  
  759. (sysdep-defun match-string (num &optional string)
  760.   "Return string of text matched by last search.
  761. NUM specifies which parenthesized expression in the last regexp.
  762.  Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
  763. Zero means the entire text matched by the whole regexp or whole string.
  764. STRING should be given if the last search was by `string-match' on STRING."
  765.   (if (match-beginning num)
  766.       (if string
  767.       (substring string (match-beginning num) (match-end num))
  768.     (buffer-substring (match-beginning num) (match-end num)))))
  769.  
  770. (sysdep-defun add-hook (hook-var function &optional at-end)
  771.   "Add a function to a hook.
  772. First argument HOOK-VAR (a symbol) is the name of a hook, second
  773.  argument FUNCTION is the function to add.
  774. Third (optional) argument AT-END means to add the function at the end
  775.  of the hook list instead of the beginning.  If the function is already
  776.  present, this has no effect.
  777. Returns nil if FUNCTION was already present in HOOK-VAR, else new
  778.  value of HOOK-VAR."
  779.       (if (not (boundp hook-var)) (set hook-var nil))
  780.       (let ((old (symbol-value hook-var)))
  781.     (if (or (not (listp old)) (eq (car old) 'lambda))
  782.         (setq old (list old)))
  783.     (if (member function old)
  784.         nil
  785.       (set hook-var
  786.            (if at-end
  787.            (append old (list function)) ; don't nconc
  788.          (cons function old))))))
  789.  
  790. (sysdep-defalias 'valid-color-name-p
  791.   (cond
  792.    ((fboundp 'x-valid-color-name-p)    ; XEmacs/Lucid
  793.     'x-valid-color-name-p)
  794.    ((and window-system
  795.      (fboundp 'color-defined-p))    ; NS/Emacs 19
  796.     'color-defined-p)
  797.    ((and window-system
  798.      (fboundp 'x-color-defined-p))    ; Emacs 19
  799.     'x-color-defined-p)
  800.    ((fboundp 'get-color)        ; Epoch
  801.     (function (lambda (color)
  802.         (let ((x (get-color color)))
  803.           (if x
  804.               (setq x (progn
  805.                 (free-color x)
  806.                 t)))
  807.           x))))
  808.    (t 'identity)))            ; All others
  809.  
  810. ;; Misc.
  811. (sysdep-defun split-string (string pattern)
  812.   "Return a list of substrings of STRING which are separated by PATTERN."
  813.   (let (parts (start 0))
  814.     (while (string-match pattern string start)
  815.       (setq parts (cons (substring string start (match-beginning 0)) parts)
  816.         start (match-end 0)))
  817.     (nreverse (cons (substring string start) parts))
  818.     ))
  819.  
  820. (sysdep-defun member (elt list)
  821.   (while (and list (not (equal elt (car list))))
  822.     (setq list (cdr list)))
  823.   list)
  824.  
  825. (sysdep-defun rassoc (key list)
  826.   (let ((found nil))
  827.     (while (and list (not found))
  828.       (if (equal (cdr (car list)) key) (setq found (car list)))
  829.       (setq list (cdr list)))
  830.     found))
  831.  
  832. (sysdep-defun display-error (error-object stream)
  833.   "Display `error-object' on `stream' in a user-friendly way."
  834.   (funcall (or (let ((type (car-safe error-object)))
  835.          (catch 'error
  836.            (and (consp error-object)
  837.             (symbolp type)
  838.             ;;(stringp (get type 'error-message))
  839.             (consp (get type 'error-conditions))
  840.             (let ((tail (cdr error-object)))
  841.               (while (not (null tail))
  842.                 (if (consp tail)
  843.                 (setq tail (cdr tail))
  844.                   (throw 'error nil)))
  845.               t)
  846.             ;; (check-type condition condition)
  847.             (get type 'error-conditions)
  848.             ;; Search class hierarchy
  849.             (let ((tail (get type 'error-conditions)))
  850.               (while (not (null tail))
  851.                 (cond ((not (and (consp tail)
  852.                          (symbolp (car tail))))
  853.                    (throw 'error nil))
  854.                   ((get (car tail) 'display-error)
  855.                    (throw 'error (get (car tail)
  856.                               'display-error)))
  857.                   (t
  858.                    (setq tail (cdr tail)))))
  859.               ;; Default method
  860.               (function
  861.                (lambda (error-object stream)
  862.                  (let ((type (car error-object))
  863.                    (tail (cdr error-object))
  864.                    (first t))
  865.                    (if (eq type 'error)
  866.                    (progn (princ (car tail) stream)
  867.                       (setq tail (cdr tail)))
  868.                  (princ (or (get type 'error-message) type)
  869.                     stream))
  870.                    (while tail
  871.                  (princ (if first ": " ", ") stream)
  872.                  (prin1 (car tail) stream)
  873.                  (setq tail (cdr tail)
  874.                        first nil)))))))))
  875.            (function
  876.         (lambda (error-object stream)
  877.           (princ "Peculiar error " stream)
  878.           (prin1 error-object stream))))
  879.        error-object stream))
  880.  
  881. (sysdep-defun find-face (face)
  882.   (car-safe (memq face (face-list))))
  883.  
  884. ;; window functions
  885.  
  886. ;; not defined in v18
  887. (sysdep-defun eval-buffer (bufname &optional printflag)
  888.   (save-excursion
  889.     (set-buffer bufname)
  890.     (eval-current-buffer)))
  891.  
  892. (sysdep-defun window-minibuffer-p (window)
  893.   "Returns non-nil if WINDOW is a minibuffer window."
  894.   (eq window (minibuffer-window)))
  895.  
  896. ;; not defined in v18
  897. (sysdep-defun window-live-p (window)
  898.   "Returns t if OBJ is a window which is currently visible."
  899.   (and (windowp window)
  900.        (window-point window)))
  901.  
  902. ;; this parenthesis closes the if statement at the top of the file.
  903.  
  904. )
  905.  
  906. ;; DO NOT put a provide statement here.  This file should never be
  907. ;; loaded with `require'.  Use `load-library' instead.
  908.  
  909. ;;; sysdep.el ends here
  910.  
  911. ;;;(sysdep.el) Local Variables:
  912. ;;;(sysdep.el) eval: (put 'sysdep-defun 'lisp-indent-function 'defun)
  913. ;;;(sysdep.el) eval: (put 'sysdep-defalias 'lisp-indent-function 'defun)
  914. ;;;(sysdep.el) eval: (put 'sysdep-defconst 'lisp-indent-function 'defun)
  915. ;;;(sysdep.el) eval: (put 'sysdep-defvar 'lisp-indent-function 'defun)
  916. ;;;(sysdep.el) End:
  917.